home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / demo / cnstest.f next >
Encoding:
Text File  |  1992-06-18  |  3.1 KB  |  123 lines
  1. C--------------------------------------------------------------------------- 
  2.  
  3. C Program name: Colour naming scheme test program.
  4.  
  5. C Author: Gareth Williams
  6.  
  7. C Description:
  8.  
  9. C Modification history : (Version), (Date), (Name), (Description).
  10.  
  11. C 1.0, 18th February 1991, G. Williams, First Version.
  12.  
  13. C 2.0, June 1992, G. Williams, Converted to SunPHIGS 2.0.
  14.  
  15. C----------------------------------------------------------------------------
  16.  
  17.        PROGRAM cnstest
  18.        LOGICAL ptkf_readphinterscript
  19.  
  20.        include './sunphigs77.h'
  21.        include './sunptk77.h'
  22.  
  23.        implicit undefined (P, p, E, e)
  24.          
  25. C     open PHIGS 
  26.        print *,('Demonstrating the colour naming scheme of the 
  27. & PHIGS Toolkit...')
  28.        print *,('Opening SunPHIGS...')
  29.  
  30.        call popph(6, 0)
  31.  
  32. C     create the workstation type (either tool or canvas) 
  33.               
  34. C     open the workstation 
  35.  
  36.        if (ptkf_readphinterscript('../../scripts/openws.scr', 0, 0) .eq.
  37. & .FALSE.) then     
  38.          goto 20
  39.        endif
  40.  
  41.        call psdus(1, PWAITD, PNIVE)
  42.  
  43.        call ptkf_inithashtables()
  44.        call ptkf_createhashtable('colourindex', 1, 256)
  45.          
  46.        call ptkf_setcolourrep(1, 'RED')
  47.  
  48.        call ptkf_drawcolourtable(1, 1, 1)  
  49.        call ppost(1, 1, 0.0)
  50.  
  51.        call prst(1, PALWAY)
  52.          
  53.        call options()
  54.          
  55.  20    print *,('Closing PHIGS...')
  56.        call pclwk(1)
  57.        call pclph()
  58.  
  59.        STOP
  60.        END
  61.  
  62. C--------------------------------------------------------------------------
  63.       
  64.        SUBROUTINE outputcolourvalues(inum, colourname, rgb)
  65.        INTEGER inum
  66.        CHARACTER*(*) colourname
  67.        REAL rgb(3)
  68.        REAL hsv(3), hsl(3)
  69.  
  70.        implicit undefined (P, p, E, e)
  71.       
  72.        print *, inum, ') RGB value of ', colourname, ' is ',
  73. & rgb(1), rgb(2), rgb(3)
  74.        call ptkf_rgbtohsv(rgb, hsv)
  75.        print *, inum, ') HSV value of ', colourname, ' is ', 
  76. & hsv(1), hsv(2), hsv(3) 
  77.        call ptkf_rgbtohsl(rgb, hsl)
  78.        print *, inum, ') HSL value of ', colourname, ' is ', 
  79. & hsl(1), hsl(2), hsl(3) 
  80.  
  81.        RETURN
  82.        END
  83.       
  84. C--------------------------------------------------------------------------
  85.       
  86.        SUBROUTINE options()
  87.        CHARACTER*50 colourname
  88.        INTEGER lencolourname
  89.        LOGICAL cnsquit
  90.        REAL echoarea(4)
  91.        REAL rgb(3)
  92.  
  93.        include './sunphigs77.h'
  94.  
  95.        implicit undefined (P, p, E, e)
  96.       
  97.        cnsquit = .FALSE.
  98.        call ptkf_limit(0.0, 0.25, 0.0, 0.01, echoarea)
  99.  10    call ptkf_readstring(1, 'white', 'Input colourname (white) >',
  100. & echoarea, 50 , colourname, lencolourname)
  101.        if (colourname(1:lencolourname) .eq. 'quit') then
  102.          cnsquit = .TRUE.
  103.        else
  104.          call ptkf_cnstorgb(colourname(1:lencolourname), rgb)
  105.          call pscr(1, 1, 3, rgb)
  106.          call pemst(1)
  107.          call ptkf_drawcolourtable(1, 1, 1)      
  108.          call outputcolourvalues(1, colourname, rgb)
  109.        endif
  110.  
  111.        call prst(1, PALWAY)
  112.  
  113.        if (cnsquit .eq. .FALSE.) then
  114.          goto 10
  115.        endif
  116.  
  117.        RETURN
  118.        END
  119.  
  120. C--------------------------------------------------------------------------
  121.  
  122. C end of cnstest.f
  123.